home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
t3_1
/
risc_src.lha
/
risc_sources
/
xlib
/
orbit_fix.t
< prev
next >
Wrap
Text File
|
1990-06-01
|
4KB
|
97 lines
(herald orbit_fix)
(define (generate-foreign-call node)
(destructure (((#f foreign rep-list value-rep . args) (call-args node)))
(emit risc/store 'l sp (reg-offset nil-reg slink/saved-sp))
(emit risc/store 'l ssp (reg-offset nil-reg slink/saved-ssp))
(emit risc/store 'l crit-reg (reg-offset nil-reg slink/saved-crit))
(let* ((rep-list (map cadr (leaf-value rep-list)))
(replen (length rep-list))
(bump-bytes (+ (* (max 0 (- replen 4)) 4) 24))) ;24=base stack frame
(emit risc/sub (machine-num bump-bytes) sSP sSP)
(emit risc/store 'l link-reg (reg-offset ssp (fx- bump-bytes 4)))
(cond ((every? (lambda (x) (neq? x 'rep/double)) rep-list)
(receive (reg-args stack-args)
(if (fx<= replen 4)
(return rep-list '())
(return (nthcdr rep-list (fx- replen 4))
(reverse (sublist rep-list 0 (fx- replen 4)))))
(do ((reps stack-args (cdr reps))
(i 16 (fx+ i 4))
(in A5 (fx+ in 1)))
((null? reps)
(do ((in (length reg-args) (fx- in 1))
(out (fx+ (length reg-args) 1) (fx- out 1))
(reps reg-args (cdr reps)))
((null? reps))
(pointer->rep in out (car reps))
(lock out)))
(cond ((fx< in AN)
(pointer->rep in AN (car reps)))
(else
(emit risc/load 'l
(reg-offset extra-args (+ (* (- in AN) 8) %%car))
parassign-extra)
(pointer->rep parassign-extra AN (car reps))))
(emit risc/store 'l AN (reg-offset ssp i)))))
((or (any? (lambda (x) (neq? x 'rep/double)) rep-list)
(fx> (length rep-list) 2))
(bug "Can't deal with this mix of float reps"))
((null? (cdr rep-list))
(asemit mips/fload `((reg-offset ,A1 2) 12))
(asemit mips/fload `((reg-offset ,A1 6) 13)))
(else
(asemit mips/fload `((reg-offset ,A1 2) 12))
(asemit mips/fload `((reg-offset ,A1 6) 13))
(asemit mips/fload `((reg-offset ,A2 2) 14))
(asemit mips/fload `((reg-offset ,A2 6) 15))))
(generate-move (lookup-value node (leaf-value foreign)) an)
(emit risc/load 'l (reg-offset an 6) an)
(emit mips/jalr an link-reg)
(emit mips/noop)
(generate-move zero extra-args)
(generate-move zero extra)
(do ((i a2 (fx+ i 1)))
((fx> i an+1))
(generate-move zero i))
(emit risc/load 'l (reg-offset ssp (fx- bump-bytes 4)) link-reg)
(emit risc/add (machine-num bump-bytes) sSP sSP))
(case (leaf-value value-rep)
((rep/undefined ignore)
(generate-move zero a1)
(generate-move zero p))
((rep/double)
(generate-move zero p)
(generate-move (machine-num header/double-float) AN)
(generate-move (machine-num 8) scratch)
(generate-slink-call slink/make-extend)
(asemit mips/fstore `(1 (reg-offset ,AN 6))) ;register $f1
(asemit mips/fstore `(0 (reg-offset ,AN 2))) ;register $f0
(generate-move AN A1)) ; return consed flonum
(else
(rep->pointer P A1 (leaf-value value-rep)) ;P = register $2
(generate-move zero p))))
(emit risc/store 'l zero (reg-offset nil-reg slink/saved-ssp)))
(define (pointer->rep from to rep)
(case rep
((rep/pointer) (generate-move from to))
((rep/extend) (emit risc/add (machine-num 2) from to))
((rep/c-pointer)
(emit risc/add (machine-num 2) from to)
(emit risc/srl (machine-num 2) to to)
(emit risc/sll (machine-num 2) to to))
((rep/string)
(emit risc/load 'l (reg-offset from 2) vector)
(emit risc/load 'l (reg-offset from 6) scratch)
(emit risc/add scratch vector vector)
(emit risc/add (machine-num 2) vector to))
((rep/char)
(emit risc/srl (machine-num 8) from to))
(else
(emit risc/sra (machine-num 2) from to))))